home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 376-400 / disk_386 / xlispstat / src2.lzh / XLisp-Stat / utilities.c < prev    next >
C/C++ Source or Header  |  1990-10-02  |  13KB  |  623 lines
  1. /* utilities - basic utility functions                                 */
  2. /* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney                  */
  3. /* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz    */
  4. /* You may give out copies of this software; for conditions see the    */
  5. /* file COPYING included with this distribution.                       */
  6.  
  7. #include <stdlib.h>
  8. #include "xlisp.h"
  9. #include "osdef.h"
  10. #ifdef ANSI
  11. #include "xlproto.h"
  12. #include "xlsproto.h"
  13. #else
  14. #include "xlfun.h"
  15. #include "xlsfun.h"
  16. #endif ANSI
  17. #include "xlsvar.h"
  18.  
  19. /************************************************************************/
  20. /**                           Basic Utilities                          **/
  21. /************************************************************************/
  22.  
  23. /* find length of a list */
  24. int llength(x)
  25.      LVAL x;
  26. {
  27.   int n;
  28.   
  29.   for (n = 0; consp(x); n++, x = cdr(x));
  30.  
  31.   return(n);
  32. }
  33.  
  34. /* return list of two elements */
  35. LVAL list2(x1, x2)
  36.      LVAL x1, x2;
  37. {
  38.   LVAL list, y1, y2;
  39.   
  40.   /* protect some pointers */
  41.   xlstkcheck(3);
  42.   xlsave(list);
  43.   xlsave(y1); /* redundant initialization of y1 and y2 in macro JKL */
  44.   xlsave(y2);
  45.   
  46.   y1 = x1;
  47.   y2 = x2;
  48.   list = consa(y2);
  49.   list = cons(y1, list);
  50.   
  51.   /* restore the stack frame */
  52.   xlpopn(3);
  53.   
  54.   return(list);
  55. }
  56.  
  57. /* return list of three elements */
  58. LVAL list3(x1, x2, x3)
  59.      LVAL x1, x2, x3;
  60. {
  61.   LVAL list, y1, y2, y3;
  62.   
  63.   /* protect some pointers */
  64.   xlstkcheck(4);
  65.   xlsave(list);
  66.   xlsave(y1); /* redundant initialization of y1, y2, and y3 in macro JKL */
  67.   xlsave(y2);
  68.   xlsave(y3);
  69.  
  70.   y1 = x1;
  71.   y2 = x2;
  72.   y3 = x3;
  73.   list = consa(y3);
  74.   list = cons(y2, list);
  75.   list = cons(y1, list);
  76.   
  77.   /* restore the stack frame */
  78.   xlpopn(4);
  79.   
  80.   return(list);
  81. }
  82.  
  83. /* return the i-th argument, without popping it; signal an error if needed. */
  84. LVAL peekarg(i)
  85.      int i;
  86. {
  87.   if (xlargc <= i) xltoofew();
  88.   else return(xlargv[i]);
  89. }
  90.  
  91. /* Get the next argument from the list or the stack; cdr the list */
  92. LVAL getnextarg(plist, from_stack)
  93.      LVAL *plist;
  94.      int from_stack;
  95. {
  96.   LVAL arg;
  97.   if (from_stack) arg = xlgetarg();
  98.   else if (consp(*plist)) {
  99.     arg = car(*plist);
  100.     *plist = cdr(*plist);
  101.   }
  102.   else
  103.     xlfail("no arguments left");
  104.   return(arg);
  105. }
  106.  
  107. /* Get the next element in the sequence; cdr the pointer if it is a list */
  108. LVAL getnextelement(pseq, i)
  109.      LVAL *pseq;
  110.      int i;
  111. {
  112.   LVAL value;
  113.  
  114.   if (vectorp(*pseq)) value = getelement(*pseq, i);
  115.   else {
  116.     if (! consp(*pseq)) xlerror("not a list", *pseq);
  117.     value = car(*pseq);
  118.     *pseq = cdr(*pseq);
  119.   }
  120.   return(value);
  121. }
  122.  
  123. /* get and check a sequence argument */
  124. LVAL xsgetsequence()
  125. {
  126.   LVAL arg;
  127.   
  128.   arg = xlgetarg();
  129.   if (! sequencep(arg)) xlerror("not a sequence", arg);
  130.   return(arg);
  131. }
  132.  
  133. /* set a fixnum node */
  134. void setfixnum(node, val)
  135.      LVAL node;
  136.      FIXTYPE val;
  137. {
  138.   node->n_fixnum = val;
  139.   node->n_type = FIXNUM;
  140. }
  141.  
  142. /* Set the next element in the sequence; cdr the pointer if it is a list */
  143. void setnextelement(pseq, i, value)
  144.      LVAL *pseq, value;
  145.      int i;
  146. {
  147.   if (vectorp(*pseq)) setelement(*pseq, i, value);
  148.   else {
  149.     rplaca(*pseq, value);
  150.     *pseq = cdr(*pseq);
  151.   }
  152. }
  153.  
  154. /* Check for a nonnegative integer */
  155. LVAL checknonnegint(x)
  156.      LVAL x;
  157. {
  158.   if (! fixp(x) || getfixnum(x) < 0) xlerror("Not a nonnegative integer", x);
  159.   return(x);
  160. }
  161.  
  162. /* return value of a number coerced to a double */
  163. double makedouble(x)
  164.      LVAL x;
  165. {
  166.   if (! numberp(x)) xlerror("not a number", x);
  167.   return((fixp(x)) ? (double) getfixnum(x) : getflonum(x));
  168. }
  169.  
  170. /************************************************************************/
  171. /**                  Function Application Utilities                    **/
  172. /************************************************************************/
  173.  
  174. void pushargvec(fun, argc, argv)
  175.      LVAL fun, *argv;
  176.      int argc;
  177. {
  178.   LVAL *newfp;
  179.   int i;
  180.  
  181.   /* build a new argument stack frame */
  182.   newfp = xlsp;
  183.   pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  184.   pusharg(fun);
  185.   pusharg(cvfixnum((FIXTYPE)argc));
  186.  
  187.   /* push the arguments */
  188.   for (i = 0; i < argc; i++)
  189.     pusharg(argv[i]);
  190.  
  191.   /* establish the new stack frame */
  192.   xlfp = newfp;
  193. }
  194.     
  195. LVAL xsapplysubr(f, args)
  196. #ifdef ANSI
  197.      LVAL (*f)(void), args;
  198. #else
  199.      LVAL (*f)(), args;
  200. #endif ANSI
  201. {
  202.   LVAL *oldargv, val;
  203.   int argc, oldargc;
  204.    
  205.   xlprot1(args); /* protect arguments while pushing */
  206.   argc = pushargs(NIL, args);
  207.   xlpop();       /* now they are protected since they are on the stack */
  208.  
  209.   oldargc = xlargc;
  210.   oldargv = xlargv;
  211.   xlargc = argc;
  212.   xlargv = xlfp + 3;
  213.   val = (*f)();
  214.   xlargc = oldargc;
  215.   xlargv = oldargv;
  216.  
  217.   /* remove the call frame */
  218.   xlsp = xlfp;
  219.   xlfp = xlfp - (int)getfixnum(*xlfp);
  220.   return(val);
  221. }
  222.  
  223. LVAL xscallsubrvec(f, argc, argv)
  224. #ifdef ANSI
  225.      LVAL (*f)(void), *argv;
  226. #else
  227.      LVAL (*f)(), *argv;
  228. #endif ANSI
  229.      int argc;
  230. {
  231.   LVAL *oldargv, val;
  232.   int oldargc;
  233.    
  234.   pushargvec(NIL, argc, argv);
  235.   oldargc = xlargc;
  236.   oldargv = xlargv;
  237.   xlargc = argc;
  238.   xlargv = xlfp + 3;
  239.   val = (*f)();
  240.   xlargc = oldargc;
  241.   xlargv = oldargv;
  242.  
  243.   /* remove the call frame */
  244.   xlsp = xlfp;
  245.   xlfp = xlfp - (int)getfixnum(*xlfp);
  246.   return(val);
  247. }
  248.  
  249. LVAL xscallsubr1(f, x)
  250.      LVAL (*f)(), x;
  251. {
  252.   return(xscallsubrvec(f, 1, &x));
  253. }
  254.  
  255. LVAL xscallsubr2(f, x, y)
  256.      LVAL (*f)(), x, y;
  257. {
  258.   LVAL args[2];
  259.  
  260.   args[0] = x;
  261.   args[1] = y;
  262.   return(xscallsubrvec(f, 2, args));
  263. }
  264.  
  265. LVAL xsfuncall1(fun, x)
  266.      LVAL fun, x;
  267. {
  268.   pushargvec(fun, 1, &x);
  269.   return(xlapply(1));
  270. }
  271.  
  272. LVAL xsfuncall2(fun, x, y)
  273.      LVAL fun, x, y;
  274. {
  275.   LVAL args[2];
  276.   
  277.   args[0] = x;
  278.   args[1] = y;
  279.   pushargvec(fun, 2, args);
  280.   return(xlapply(2));
  281. }
  282.  
  283. #ifdef DODO
  284. /************************************************************************/
  285. /**                                                                    **/
  286. /**               Temporary Storage Allocation Routines                **/
  287. /**                                                                    **/
  288. /************************************************************************/
  289.  
  290. char *xstcalloc(n, size)
  291.      int n, size;
  292. {
  293.   char *result;
  294.  
  295.   if ((result = calloc((unsigned) n, (unsigned) size)) == NULL) 
  296.     xlfail("memory allocation failed");
  297.   return(result);
  298. }
  299.  
  300. void xstfree(ptr) 
  301. /*char*/ void *ptr;/* changed JKL */
  302. {
  303.   free(ptr);
  304. }
  305.  
  306. /************************************************************************/
  307. /**                                                                    **/
  308. /**         Lisp to/from C/Fortran Data Conversion Routines            **/
  309. /**                                                                    **/
  310. /************************************************************************/
  311. double *data_to_double(x)
  312.      LVAL x;
  313. {
  314.   LVAL data, val;
  315.   double *result;
  316.   int n, rows, cols, i, j;
  317.  
  318.   if (matrixp(x)) n = getsize(arraydata(x));
  319.   else if (sequencep(x)) n = seqlen(x);
  320.   else xlerror("Bad data type", x);
  321.  
  322.   result = (double *) xstcalloc(n, sizeof(double));
  323.  
  324.   data = (sequencep(x)) ? x : arraydata(x);
  325.  
  326.   if (matrixp(x)) {
  327.     rows = numrows(x);
  328.     cols = numcols(x);
  329.     for (i = 0; i < rows; i++)
  330.       for (j = 0; j < cols; j++) {
  331.     val = getelement(data, cols * i + j);
  332.     if (! numberp(val)) {
  333.       free(result);
  334.       xlerror("element not a number", val);
  335.     }
  336.     result[i + rows * j] = (fixp(val)) ? getfixnum(val) : getflonum(val);
  337.       }
  338.   }
  339.   else {
  340.     for (i = 0; i < n; i++) {
  341.       val = getnextelement(&x, i);
  342.       if (! numberp(val)) {
  343.     free(result);
  344.     xlerror("element not a number", val);
  345.       }
  346.       result[i] = (fixp(val)) ? getfixnum(val) : getflonum(val);
  347.     }
  348.   }
  349.   return(result);
  350. }
  351.  
  352. LVAL double_to_matrix(x, n, k)
  353.      double *x;
  354.      int n, k;
  355. {
  356.   LVAL dim, nn, kk, val, result, result_data;
  357.   int i, j;
  358.  
  359.   /* protect some pointers */
  360.   xlstkcheck(5);
  361.   xlsave(dim);
  362.   xlsave(nn);
  363.   xlsave(kk);
  364.   xlsave(val);
  365.   xlsave(result);
  366.   
  367.   nn = cvfixnum((FIXTYPE) n);
  368.   kk = cvfixnum((FIXTYPE) k);
  369.   dim = list2(nn, kk);
  370.   result = newarray(dim, NIL, NIL);
  371.   result_data = arraydata(result);
  372.  
  373.   for (i = 0; i < n; i++)
  374.     for (j = 0; j < k; j++) {
  375.       val = cvflonum((FLOTYPE) x[i + n * j]);
  376.       setelement(result_data, k * i + j, val);
  377.     }
  378.   
  379.   /* restore the stack frame */
  380.   xlpopn(5);
  381.   
  382.   return(result);
  383. }
  384.   
  385. LVAL double_to_sequence(x, n, list)
  386.      double *x;
  387.      int n, list;
  388. {
  389.   LVAL val, result, next;
  390.   int i;
  391.  
  392.   /* protect some pointers */
  393.   xlstkcheck(2);
  394.   xlsave(val);
  395.   xlsave(result);
  396.   
  397.   result = (list) ? mklist(n, NIL) : newvector(n);
  398.   
  399.   for (i = 0, next = result; i < n; i++) {
  400.     val = cvflonum((FLOTYPE) x[i]);
  401.     setnextelement(&next, i, val);
  402.   }
  403.   
  404.   /* restore the stack frame */
  405.   xlpopn(2);
  406.   
  407.   return(result);
  408. }
  409. #endif DODO
  410. /***********************************************************************/
  411. /**                     Sequence Coercion Functions                   **/
  412. /***********************************************************************/
  413.  
  414. LVAL coerce_to_list(x)
  415.      LVAL x;
  416. {
  417.   LVAL next, result;
  418.   int n, i;
  419.   
  420.   /* save the result pointer */
  421.   xlsave1(result);
  422.   
  423.   if (displacedarrayp(x))
  424.     result = array_to_nested_list(x);
  425.   else if (vectorp(x)) {
  426.     n = getsize(x);
  427.     result = mklist(n, NIL);
  428.     for (i = 0, next = result; i < n; i++, next = cdr(next))
  429.       rplaca(next, getelement(x, i));
  430.   }
  431.   else if (objectp(x))
  432.     return(NIL); /* include standard coercion message later */
  433.   else if (listp(x))
  434.     result = x;
  435.   else if (atom(x)) {
  436.     result = consa(x);
  437.   }
  438.   else result = NIL;
  439.   
  440.   /* restore the stack frame */
  441.   xlpop();
  442.   
  443.   return(result);
  444. }
  445.  
  446. LVAL coerce_to_vector(x)
  447.      LVAL x;
  448. {
  449.   LVAL next, result;
  450.   int n, i;
  451.   
  452.   /* save the result pointer */
  453.   xlsave1(result);
  454.   
  455.   if (displacedarrayp(x)) result = arraydata(x);
  456.   else if (vectorp(x)) result = x;
  457.   else if (objectp(x))
  458.     return(NIL); /* include standard coercion message later */
  459.   else if (listp(x)) {
  460.     n = llength(x);
  461.     result = newvector(n);
  462.     for (i = 0, next = x; i < n; i++, next = cdr(next))
  463.       setelement(result, i, car(next));
  464.   }
  465.   else if (atom(x)) {
  466.     result = newvector(1);
  467.     setelement(result, 0, x);
  468.   }
  469.   else result = NIL;
  470.   
  471.   /* restore the previous stack frame */
  472.   xlpop();
  473.   
  474.   return(result);
  475. }
  476.  
  477. /*************************************************************************/
  478. /**                          Copying Functions                          **/
  479. /*************************************************************************/
  480.  
  481. LVAL copylist(list)
  482.      LVAL list;
  483. {
  484.   LVAL result, nextl, nextr;
  485.   
  486.   if (! listp(list)) xlerror("not a list", list);
  487.   
  488.   /* protect the result pointer */
  489.   xlsave1(result);
  490.   
  491.   result = mklist(llength(list), NIL);
  492.   for (nextl = list, nextr = result; consp(nextl);
  493.        nextl = cdr(nextl), nextr = cdr(nextr)) {
  494.     rplaca(nextr, car(nextl));
  495.   }
  496.   
  497.   /* restore the stack frame */
  498.   xlpop();
  499.   
  500.   return(result);
  501. }
  502.  
  503. LVAL copyvector(v)
  504.      LVAL v;
  505. {
  506.   LVAL result;
  507.   int n, i;
  508.   
  509.   if (! vectorp(v)) xlerror("not a vector", v);
  510.   
  511.   /* protect the result pointer */
  512.   xlsave1(result);
  513.   
  514.   n = getsize(v);
  515.   result = newvector(n);
  516.   for (i = 0; i < n; i++) {
  517.     setelement(result, i, getelement(v, i));
  518.   }
  519.   
  520.   /* restore the stack frame */
  521.   xlpop();
  522.   
  523.   return(result);
  524. }
  525.  
  526. /***************************************************************************/
  527. /**                    Statistical Functions (sort of)                    **/
  528. /***************************************************************************/
  529.  
  530. LVAL splitlist(list, len)
  531.      LVAL list;
  532.      int len;
  533. {
  534.   LVAL result, sublist, next_r, next_s, next;
  535.   int numlists, n;
  536.   
  537.   if (len < 1) xlfail("invalid length for sublists");
  538.   
  539.   /* protect some pointers */
  540.   xlsave1(result);
  541.   
  542.   n = llength(list);
  543.   if ((n % len) != 0)
  544.     xlfail("list not divisible by this length");
  545.   else 
  546.     numlists = n / len;
  547.   
  548.   result = mklist(numlists, NIL);
  549.   for (next = list, next_r = result; consp(next_r); next_r = cdr(next_r)) {
  550.     sublist = mklist(len, NIL);
  551.     rplaca(next_r, sublist);
  552.     for (next_s = sublist; consp(next_s); 
  553.      next_s = cdr(next_s), next = cdr(next))
  554.       rplaca(next_s, car(next));
  555.   }
  556.  
  557.   /* restore the stack frame */
  558.   xlpop();
  559.   
  560.   return(result);
  561. }
  562.  
  563. /* replicates a list n times */ 
  564. LVAL lrepeat(arg, n)
  565.      LVAL arg;
  566.      int n;
  567. {
  568.   LVAL data, nextd, nextr, result;
  569.   
  570.   /* protect some pointers */
  571.   xlstkcheck(2);
  572.   xlsave(data);
  573.   xlsave(result);
  574.   
  575.   data = coerce_to_list(arg);
  576.   
  577.   /* make new data list */
  578.   result = mklist(n * llength(data), NIL);
  579.   
  580.   /* insert values from data into list */
  581.   for (nextr = result, nextd = data; consp(nextr); 
  582.        nextr = cdr(nextr), nextd = cdr(nextd)) {
  583.     if (nextd == NIL) nextd = data; /* cycle through the data */
  584.     rplaca(nextr, car(nextd));
  585.   }
  586.  
  587.   /* restore the stack frame */
  588.   xlpopn(2);
  589.   
  590.   return(result);
  591. }
  592.  
  593. /* Flatten a nested list to depth rank */
  594. LVAL nested_list_to_list(list, rank)
  595.      LVAL list;
  596.      int rank;
  597. {
  598.   LVAL result;
  599.   int i;
  600.   
  601.   /* protect the result pointer */
  602.   xlsave1(result);
  603.   
  604.   for (i = 1, result = list; i < rank; i++)
  605.     result = concatenate(s_list, result);
  606.   
  607.   /* restore the previous stack frame */
  608.   xlpop();
  609.   
  610.   return (result);
  611. }
  612.  
  613. int xsboolkey(key, dflt)
  614.     LVAL key;
  615.     int dflt;
  616. {
  617.   LVAL val;
  618.   int result = dflt;
  619.   
  620.   if (xlgetkeyarg(key, &val)) result = ((val != NIL) ? TRUE : FALSE);
  621.   return(result);
  622. }
  623.